Programmer Plus 2007/Programmer-Plus-2007.iso/Programming/Low Level Languages/PCLOGO/LOGO/SHED.LG_/SHED.LG

Text File | 1994-05-23 | 11.6 KB | 460 lines

; Turtle Shape Editor (C) 1994 by Harvard Associates, Inc.

IGNORE IF NOT DEFINED? "BEEP [LOAD "WINDOWS]

NOCASE

TO SHED
    SHAPE.EDITOR
END

TO SHAPE.EDITOR
    ; start with the shape of the current turtle
    LOCAL "LIST
    MAKE "LIST (LIST (SHAPE 1) (SHAPE 2) (SHAPE 3) (SHAPE 4))
    DRAW SS
    (SETSHAPE ITEM 1 :LIST ITEM 2 :LIST ITEM 3 :LIST ITEM 4 :LIST)
    SETUP.WINDOW
    GET.SHAPE
    DRAW.WINDOW
    PROCESS.MOUSE
    DRAW
    TELLALL 1 4 (SETSHAPE) HT
    SETEXTENT 0
    TELL 0 ST
    (SETSHAPE ITEM 1 :LIST ITEM 2 :LIST ITEM 3 :LIST ITEM 4 :LIST)
    (SETMOUSESHAPE)
END

; define various constant values and set up the coordinate system

TO SETUP.WINDOW
    LOCAL "I
    MAKE "DOT.SIZE 15                ; size of a drawn dot
    MAKE "WIDTH 16 * :DOT.SIZE + 200 ; define window width and height
    MAKE "HEIGHT 16 * :DOT.SIZE + 16
    MAKE "X.OFFSET (-:WIDTH / 2)
    MAKE "Y.OFFSET -8 * :DOT.SIZE + :DOT.SIZE + 8
    MAKE "TEXT.POS LIST (:X.OFFSET + 2) (:HEIGHT / 2 + 1)
    ; the lower left corners of the four shapes
    MAKE "SHAPE.POS (ARRAY 4 [[50 60][90 60][130 60][170 60]])
    ; the lower left corners of the buttons
    MAKE "BUTTON.POS (ARRAY 5 [ \
        [Load 80 15] \
        [Save 80 -15] \
        [Restore 80 -45] \
        [Clear 80 -75] \
        [Done 80 -115]])
    SETWINSIZE :WIDTH + 2 :HEIGHT + 2
    (SETEXTENT :WIDTH/2 + 1 :HEIGHT/2 + 2); tie extent to window
    MAKE "SHAPE BYTEARRAY [4 32]  ; storage for the turtle shape
    MAKE "ORIG.SHAPE BYTEARRAY [4 32]; original shape for restore
    ; shape changed flags
    FOR "I 1 4 [MAKE WORD "CHANGED. :I "FALSE]
    MAKE "CUR.SHAPE 1             ; shape 1 is the current shape (n - 1)
    MAKE "CUR.TEXT.NR 0           ; current help text number
END

; draw the initial window look

TO DRAW.WINDOW
    LOCAL "I
    DRAW
    SET.TITLE [Turtle Shape Editor]
    ; draw the bottom line
    HT SETPC 0
    PU SETXY LIST (-:WIDTH/2) (:HEIGHT / 2 - 16)
    PD SETXY LIST ( :WIDTH/2) (:HEIGHT / 2 - 16)
    DRAW.GRID
    ; draw the four boxes
    SETPC 0
    FOR "I 1 4 [DRAW.BOX :I]
    FOR "I 1 4 [SETUP.TURTLE :I]
    FOR "I 1 5 [DRAW.BUTTON :I]
    DRAW.DOTS
    TELL 0
END

; setup a demo turtle

TO SETUP.TURTLE :NR
    (LOCAL "X "Y "POS)
    MAKE "POS AGET :SHAPE.POS :NR - 1
    MAKE "X (FIRST :POS) + 14
    MAKE "Y (LAST :POS)  + 14
    TELL :NR
    SETPC 4
    PU SETXY LIST :X :Y
    PD SETH 22.5 * (:NR - 1) ST
    TELL 0
END

TO DRAW.BUTTON :NR
    (LOCAL "POS "SIZE "X "Y)
    MAKE "POS AGET :BUTTON.POS :NR - 1
    PU SETXY BF :POS
    PD SETPC 7          ; light gray interior
    (STAMPRECT 90 25 "TRUE)
    ; draw the gray and white interior frame
    MAKE "X ITEM 2 :POS
    MAKE "Y ITEM 3 :POS
    PU SETXY LIST :X + 2 :Y + 1
    SETWIDTH 2
    SETPC 15
    PD FD 21 RT 90 FD 86
    SETPC 8
    RT 90 FD 21 RT 90 FD 86
    SETWIDTH 1 SETHEADING 0
    SETPEN [PU 0] SETXY BF :POS
    PD STAMPRECT 90 25     ; black border
    MAKE "SIZE TEXTSIZE :.GRAPHICS FIRST :POS
    PU
          SETY YCOR + (25 - (LAST :SIZE)) / 2 + LAST :SIZE
    SETX XCOR + (90 - (FIRST :SIZE)) / 2
    PD TURTLETEXT FIRST :POS
END

; draw the shape grid with the current shape

TO DRAW.GRID
    (LOCAL "X "Y)
    PU
      SETXY COMPUTE.COORDS 0 15
    SETPC 15 PD
    ; erase the grid
    (STAMPRECT 16 * :DOT.SIZE 16 * :DOT.SIZE "TRUE)
    SETPC 0
    FOR "X 0 16 [DRAW.VLINE :X]
    FOR "Y 0 15 [DRAW.HLINE :Y]
    MAKE "OLD.POS [-1 -1]         ; old mouse posiiton in bit array
    MAKE "OLD.VAL 0               ; old dot value in mouse array
END

; draw the dots within the shape grid

TO DRAW.DOTS
    (LOCAL "X "Y "OLD)
    MAKE "OLD MOUSESHAPE
    SETMOUSESHAPE 3
    FOR "X 0 15 [ \
        FOR "Y 0 15 [(DRAW.DOT :X :Y TEST.BIT :X :Y "FALSE)]]
    SETMOUSESHAPE :OLD
END

TO DRAW.HLINE :Y
    PU
      SETXY LIST :X.OFFSET (- :Y * :DOT.SIZE + :Y.OFFSET)
    PD SETX 16 * :DOT.SIZE + :X.OFFSET - 1
END

TO DRAW.VLINE :X
    PU
      SETXY LIST (:X * :DOT.SIZE + :X.OFFSET - 1) (- :Y.OFFSET - :DOT.SIZE)
    PD SETY :Y.OFFSET - 2 * :DOT.SIZE - 1
END

; Draw a box around a mouse shape. Draw a thick
; box for the current shape.

TO DRAW.BOX :SHAPE.NR
    PU SETXY AGET :SHAPE.POS :SHAPE.NR - 1
    PD SETPC 15
    ; erase any old box
    SETWIDTH 3 STAMPRECT 30 30
    IF NOT :SHAPE.NR = :CUR.SHAPE [SETWIDTH 1]
    SETPC 0 STAMPRECT 30 30
    SETWIDTH 1
END

; draw a dot at a certain location
; X and Y vary between 0 and 15

TO DRAW.DOT :X :Y :ON [:FORCE "TRUE] 3
    IF AND NOT :ON NOT :FORCE THEN STOP     ; do not draw white if no force
    TEST :ON
    IFTRUE [SETPC 12]                       ; red for on-dots
    IFFALSE [SETPC 15]                      ; white for off-dots
    MAKE "X COMPUTE.COORDS :X :Y
    PU SETXY :X PD
    (STAMPRECT :DOT.SIZE :DOT.SIZE "TRUE)   ; draw filled rect
END

; compute the lower left corner for a given coordinate
; RETURN IT AS A TWO-ELEMENT LIST FOR X and Y

TO COMPUTE.COORDS :X :Y
    MAKE "X :X * :DOT.SIZE + :X.OFFSET      ; starting pos of rect
    MAKE "Y (- :Y * :DOT.SIZE + :Y.OFFSET)
    OUTPUT LIST :X :Y
END

; convert the current shape into a BYTEARRAY 32x4
; and store it into SHAPE

TO GET.SHAPE
    FILLARRAY :SHAPE (LIST (SHAPE 1) (SHAPE 2) (SHAPE 3) (SHAPE 4))
    FILLARRAY :ORIG.SHAPE (LIST (SHAPE 1) (SHAPE 2) (SHAPE 3) (SHAPE 4))
END

; convert the bytearray SHAPE into a shape list and set the shape

TO SET.SHAPE
    LOCAL "LIST
    MAKE "LIST LISTARRAY :SHAPE
    (SETSHAPE ITEM 1 :LIST ITEM 2 :LIST ITEM 3 :LIST ITEM 4 :LIST)
END

; compute the position of any given bit in the current shape
; the index into the BYTEARRAY is stored in BYTE,
; and the bit mask which is used to AND or OR the bit into
; the byte number is stored in BIT
; every two elements in the shape list are one row of dots
; if X is >= 8, then the second element is used

TO COMPUTE.BIT.POSITION :X :Y
    MAKE "BYTE :Y * 2
    MAKE "BIT :X
    IF :X >= 8 THEN MAKE "BYTE :BYTE + 1 MAKE "BIT :X - 8
    MAKE "BIT LSH #h80 :BIT
    MAKE "BYTE LIST (:CUR.SHAPE - 1) :BYTE
END

; test a bit for being set in the current shape
; returns TRUE or FALSE

TO TEST.BIT :X :Y
    COMPUTE.BIT.POSITION :X :Y
    OUTPUT NOT (LOGAND AGET :SHAPE :BYTE :BIT) = 0
END

; set or reset a bit in the current shape

TO SET.BIT :X :Y :ON
    COMPUTE.BIT.POSITION :X :Y
    IF :ON ASET :SHAPE :BYTE LOGOR AGET :SHAPE :BYTE :BIT \
        ELSE ASET :SHAPE :BYTE LOGAND AGET :SHAPE :BYTE LOGNOT :BIT
    MAKE WORD "CHANGED. :CUR.SHAPE "TRUE
    TELL :CUR.SHAPE
    SET.SHAPE
    TELL 0
END

; perform a hit test for the given turtle coordinates.
; If a box if hit, return 1 to 4 according to the shape.
; If a dot square is hit, return a list of X and Y
; coordinates ranging from 0 to 15 each. If a button is hit,
; negative values from -1 to -4 are outputted

TO HIT.TEST :COORDS
    (LOCAL "X "Y "I)
    MAKE "X FIRST :COORDS
    MAKE "Y LAST :COORDS
    IF :X < (:X.OFFSET + 16 * :DOT.SIZE) [OUTPUT OVER.DOT? :X :Y]
    FOR "I 1 4 [IF OVER.BOX? :I :X :Y [OUTPUT :I]]
    FOR "I 1 5 [IF OVER.BUTTON? :I :X :Y [OUTPUT (- :I)]]
    OUTPUT []
END

; check if the given coordinates X and Y are over a dot box
; and output a two-element list of the bit positions of that dot
; if so. Output an empty list if not.
; dot box X and Y, where X and Y are the bit positions 0-15
; output TRUE or FALSE

TO OVER.DOT? :X :Y
    MAKE "X   INT (:X - :X.OFFSET) / :DOT.SIZE
    MAKE "Y (- INT (:Y - :HEIGHT/2 + 16) / :DOT.SIZE)
    IF AND :X < 16 :Y < 16 [OUTPUT LIST :X :Y]
    OUTPUT []
END

TO OVER.BOX? :NR :X :Y
    (LOCAL "X1 "Y1 "X2 "Y2)
    MAKE "X2 AGET :SHAPE.POS :NR - 1
    MAKE "X1 FIRST :X2
    MAKE "Y1 LAST :X2
    MAKE "X2 :X1 + 29
    MAKE "Y2 :Y1 + 29
    OUTPUT (AND :X >= :X1 :X <= :X2 :Y >= :Y1 :Y <= :Y2)
END

TO OVER.BUTTON? :NR :X :Y
    (LOCAL "X1 "Y1 "X2 "Y2)
    MAKE "X2 BF AGET :BUTTON.POS :NR - 1
    MAKE "X1 FIRST :X2
    MAKE "Y1 LAST :X2
    MAKE "X2 :X1 + 89
    MAKE "Y2 :Y1 + 24
    OUTPUT (AND :X >= :X1 :X <= :X2 :Y >= :Y1 :Y <= :Y2)
END

; process mouse input

TO PROCESS.MOUSE
    LOCAL "POS
    MAKE "POS HIT.TEST MOUSE
    ; change the mouse shape according to the position
    IF EMPTY? :POS THEN SETMOUSESHAPE 1 HELP.TEXT 0 \
        ELSE IF LIST? :POS THEN SETMOUSESHAPE 15 HELP.TEXT 1 \
            ELSE IF :POS > 0 THEN SETMOUSESHAPE 17 HELP.TEXT 2 \
                ELSE SETMOUSESHAPE 1 HELP.TEXT :POS
    ; process mouse clicks
    IF BUTTON? 1 THEN IF PROCESS.CLICK1 :POS THEN STOP
    IF BUTTON? 2 THEN PROCESS.CLICK2 :POS
    PROCESS.MOUSE
END

; set a certain help text

TO HELP.TEXT :TEXT.NR
    IF :TEXT.NR = :CUR.TEXT.NR THEN STOP
    PU SETXY :TEXT.POS
     ; erase any old text
    SETH 0 PU BK 16 PD
    SETPC 15 PD (STAMPRECT :WIDTH 18 "TRUE)
    PU FD 16 PD SETPC 0
    ; draw any new text
    IF :TEXT.NR = 1 THEN TT [Click the left button to set, the right button to reset a dot]
    IF :TEXT.NR = 2 THEN TT [Click to select a shape to edit]
    ; draw text for buttons
    IF :TEXT.NR = -1 THEN TT [Click to load a shape from disk]
    IF :TEXT.NR = -2 THEN TT [Click to save a shape to disk]
    IF :TEXT.NR = -3 THEN TT [Click to undo the changes]
    IF :TEXT.NR = -4 THEN TT [Click to erase the shape]
    IF :TEXT.NR = -5 THEN TT [Click if you have finished editing]
    MAKE "CUR.TEXT.NR :TEXT.NR
END

; process a click on the left button

TO PROCESS.CLICK1 :POS
    IF EMPTY? :POS THEN OP "FALSE
    IF LIST? :POS THEN PROCESS.DOT FIRST :POS LAST :POS "TRUE OP "FALSE
    IF :POS = -1 THEN PROCESS.LOAD OP "FALSE
    IF :POS = -2 THEN PROCESS.SAVE OP "FALSE
    IF :POS = -3 THEN PROCESS.DFLT OP "FALSE
    IF :POS = -4 THEN PROCESS.ERASE OP "FALSE
    IF :POS = -5 THEN PROCESS.DONE OP "TRUE
    PROCESS.SHAPE :POS
    OP "FALSE
END

; process a click on the right button

TO PROCESS.CLICK2 :POS
    IF NOT LIST? :POS THEN STOP
    PROCESS.DOT FIRST :POS LAST :POS "FALSE
END

; process a click in the dot area

TO PROCESS.DOT :X :Y :ON
    LOCAL "VAL
    MAKE "VAL LIST :X :Y
    IF AND EQUAL? :OLD.VAL :ON EQUAL? :VAL :OLD.POS THEN STOP
    MAKE "OLD.POS :VAL
    MAKE "OLD.VAL :ON
    SET.BIT :X :Y :ON
    DRAW.DOT :X :Y :ON
    TELL :CUR.SHAPE                         ; activate the current turtle
    SET.SHAPE                               ; change the shape to show changes
    TELL 0
END

; process a click in the shape area

TO PROCESS.SHAPE :NR
    LOCAL "OLD.SHAPE
    IF :NR = :CUR.SHAPE THEN STOP
    MAKE "OLD.SHAPE :CUR.SHAPE
    MAKE "CUR.SHAPE :NR
    DRAW.BOX :OLD.SHAPE
    DRAW.BOX :CUR.SHAPE
    DRAW.GRID
    DRAW.DOTS
END

; process the DFLT button

TO PROCESS.DFLT
    LOCAL "I
    IF NOT REPLY [Do you want to restore the original shape?] THEN STOP
    MAKE "SHAPE :ORIG.SHAPE
    TELLALL 1 4
    SET.SHAPE
    TELL 0
    DRAW.GRID
    DRAW.DOTS
END

; process the LOAD button

TO PROCESS.LOAD
    IF SHAPE.CHANGED? THEN \
        IF REPLY [Do you want to save the shape?] THEN PROCESS.SAVE
    TELLALL 1 4 (SETSHAPE)
    MAKE "STANDARD.OUTPUT OPEN "NUL
    IGNORE LOAD "|*.SHP|
    CLOSE :STANDARD.OUTPUT
    MAKE "STANDARD.OUTPUT 0
    GET.SHAPE
    ST TELL 0 HT
    DRAW.GRID
    DRAW.DOTS
END

; process the SAVE button

TO PROCESS.SAVE
    (LOCAL "N "LIST "I)
    IF NOT SHAPE.CHANGED? THEN STOP
    MAKE "N CREATE "|*.SHP|
    IF :N = -1 THEN STOP
    MAKE "STANDARD.OUTPUT :N
    MAKE "LIST LISTARRAY :SHAPE
    (PR "\( "SETSHAPE "| \|)
    FOR "I 1 4 [(PR "| [| ITEM :I :LIST "|] \|)]
    PR "\)
    CLOSE :N
    MAKE "STANDARD.OUTPUT 0
    FOR "I 1 4 [MAKE WORD "CHANGED. :I "FALSE]
END

; process the ERASE button

TO PROCESS.ERASE
    IF THING WORD "CHANGED. :CUR.SHAPE \
        IF NOT REPLY [Do you really want to clear this shape?"] STOP
    FOR "I 0 31 [ASET :SHAPE LIST (:CUR.SHAPE - 1) :I 0]
    TELL :CUR.SHAPE SET.SHAPE
    TELL 0
    DRAW.GRID
END

; process the DONE button

TO PROCESS.DONE
    IF SHAPE.CHANGED? \
        IF REPLY [Do you want to save the shape?] \
            THEN PROCESS.SAVE
    TELLALL 0 4 (SETSHAPE)
    TELL 0
    SET.TITLE [Graphics]
END

; check if any shape is altered

TO SHAPE.CHANGED?
    LOCAL "I
    FOR "I 1 4 [IF THING WORD "CHANGED. :I THEN OUTPUT "TRUE]
    OUTPUT "FALSE
END

; print a nice message

CT
PR [Turtle shape editor (C) 1994 by Harvard Associates, Inc.]
PR [Enter SHED or SHAPE.EDITOR to start the program]

CASE